relPath,
) where
-import qualified Data.ByteString as B
import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
-import qualified System.FilePath.ByteString as P
import Common
import Git.Types
import qualified Data.Set as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
{- Given a set of bad objects found by git fsck, which may not
- be complete, finds and removes all corrupt objects. -}
mapM_ removeLoose (S.toList $ knownMissing fsckresults)
mapM_ removeBad =<< listLooseObjectShas r
where
- removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s)
+ removeLoose s = removeWhenExistsWith R.removeLink $
+ fromOsPath $ looseObjectFile r s
removeBad s = do
- void $ tryIO $ allowRead $ looseObjectFile r s
+ void $ tryIO $ allowRead $ fromOsPath $ looseObjectFile r s
whenM (isMissing s r) $
removeLoose s
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
-- Just in case permissions are messed up.
- allowRead packfile
+ allowRead (fromOsPath packfile)
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
- L.hPut h =<< F.readFile (toOsPath packfile)
+ L.hPut h =<< F.readFile packfile
objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
forM_ objs $ \objfile -> do
f <- relPathDirToFile tmpdir objfile
- let dest = objectsDir r P.</> f
+ let dest = objectsDir r </> f
createDirectoryIfMissing True (parentDir dest)
- moveFile objfile dest
+ moveFile (fromOsPath objfile) (fromOsPath dest)
forM_ packs $ \packfile -> do
- removeWhenExistsWith R.removeLink packfile
- removeWhenExistsWith R.removeLink (packIdxFile packfile)
+ removeWhenExistsWith R.removeLink (fromOsPath packfile)
+ removeWhenExistsWith R.removeLink (fromOsPath (packIdxFile packfile))
return True
{- Try to retrieve a set of missing objects, from the remotes of a
unlessM (boolSystem "git" [Param "init", File (fromOsPath tmpdir)]) $
giveup $ "failed to create temp repository in " ++ fromOsPath tmpdir
tmpr <- Config.read =<< Construct.fromPath tmpdir
- let repoconfig r' = localGitDir r' </> "config"
+ let repoconfig r' = localGitDir r' </> literalOsPath "config"
whenM (doesFileExist (repoconfig r)) $
F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr)
rs <- Construct.fromRemotes r
getAllRefs' :: OsPath -> IO [Ref]
getAllRefs' refdir = do
let topsegs = length (splitPath refdir) - 1
- let toref = Ref . toInternalGitPath
+ let toref = Ref . fromOsPath . toInternalGitPath
. joinPath . drop topsegs . splitPath
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
writeFile (fromOsPath dest) (fromRef sha)
packedRefsFile :: Repo -> OsPath
-packedRefsFile r = localGitDir r </> "packed-refs"
+packedRefsFile r = localGitDir r </> literalOsPath "packed-refs"
parsePacked :: String -> Maybe (Sha, Ref)
parsePacked l = case words l of
{- git-branch -d cannot be used to remove a branch that is directly
- pointing to a corrupt commit. -}
nukeBranchRef :: Branch -> Repo -> IO ()
-nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P.</> fromRef' b
+nukeBranchRef b r = removeWhenExistsWith R.removeLink $ fromOsPath $
+ localGitDir r </> toOsPath (fromRef' b)
{- Finds the most recent commit to a branch that does not need any
- of the missing objects. If the input branch is good as-is, returns it.
length indexcontents `seq` cleanup
missingIndex :: Repo -> IO Bool
-missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
+missingIndex r = not <$> doesFileExist (localGitDir r </> literalOsPath "index")
{- Finds missing and ok files staged in the index. -}
partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
| otherwise = do
(bad, good, cleanup) <- partitionIndex r
unless (null bad) $ do
- removeWhenExistsWith R.removeLink (indexFile r)
+ removeWhenExistsWith R.removeLink (fromOsPath (indexFile r))
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
- return $ map (\(file,_, _, _) -> fromRawFilePath file) bad
+ return $ map (\(file,_, _, _) -> fromOsPath file) bad
where
reinject (file, sha, mode, _) = case toTreeItemType mode of
Nothing -> return Nothing
preRepair :: Repo -> IO ()
preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do
- removeWhenExistsWith R.removeLink headfile
- writeFile (fromRawFilePath headfile) "ref: refs/heads/master"
+ removeWhenExistsWith R.removeLink (fromOsPath headfile)
+ writeFile (fromOsPath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
unless (repoIsLocalBare g) $
- void $ tryIO $ allowWrite $ indexFile g
+ void $ tryIO $ allowWrite $ fromOsPath $ indexFile g
where
- headfile = localGitDir g P.</> "HEAD"
+ headfile = localGitDir g </> literalOsPath "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s
|| isJust (extractSha (encodeBS s))
else successfulfinish modifiedbranches
corruptedindex = do
- removeWhenExistsWith R.removeLink (indexFile g)
+ removeWhenExistsWith R.removeLink (fromOsPath (indexFile g))
-- The corrupted index can prevent fsck from finding other
-- problems, so re-run repair.
fsckresult' <- findBroken False False g
void $ cleanup
where
go [] = noop
- go (info:file:rest) = mergeFile info file hashhandle ch >>=
+ go (info:file:rest) = mergeFile info (toOsPath file) hashhandle ch >>=
maybe (go rest) (\l -> streamer l >> go rest)
go (_:[]) = giveup $ "parse error " ++ show differ
{- Given an info line from a git raw diff, and the filename, generates
- a line suitable for update-index that union merges the two sides of the
- diff. -}
-mergeFile :: S.ByteString -> RawFilePath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
+mergeFile :: S.ByteString -> OsPath -> HashObjectHandle -> CatFileHandle -> IO (Maybe L.ByteString)
mergeFile info file hashhandle h = case S8.words info of
[_colonmode, _bmode, asha, bsha, _status] ->
case filter (`notElem` nullShas) [Ref asha, Ref bsha] of
) where
import Utility.DirWatcher.Types
+import Utility.OsPath
#if WITH_INOTIFY
import qualified Utility.DirWatcher.INotify as INotify
import qualified System.Win32.Notify as Win32Notify
#endif
-type Pruner = FilePath -> Bool
+type Pruner = OsPath -> Bool
canWatch :: Bool
#if (WITH_INOTIFY || WITH_KQUEUE || WITH_FSEVENTS || WITH_WIN32NOTIFY)
- to shutdown later. -}
#if WITH_INOTIFY
type DirWatcherHandle = INotify.INotify
-watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
+watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup = do
i <- INotify.initINotify
runstartup $ INotify.watchDir i dir prune scanevents hooks
#else
#if WITH_KQUEUE
type DirWatcherHandle = ThreadId
-watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle
+watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO DirWatcherHandle
watchDir dir prune _scanevents hooks runstartup = do
kq <- runstartup $ Kqueue.initKqueue dir prune
forkIO $ Kqueue.runHooks kq hooks
#else
#if WITH_FSEVENTS
type DirWatcherHandle = FSEvents.EventStream
-watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle
+watchDir :: OsPath -> Pruner -> Bool -> WatchHooks -> (IO FSEvents.EventStream -> IO FSEvents.EventStream) -> IO DirWatcherHandle
watchDir dir prune scanevents hooks runstartup =
runstartup $ FSEvents.watchDir dir prune scanevents hooks
#else
- So this will fail if there are too many subdirectories. The
- errHook is called when this happens.
-}
-watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> Bool -> WatchHooks -> IO ()
+watchDir :: INotify -> OsPath -> (OsPath -> Bool) -> Bool -> WatchHooks -> IO ()
watchDir i dir ignored scanevents hooks
| ignored dir = noop
| otherwise = do
lock <- newLock
let handler event = withLock lock (void $ go event)
flip catchNonAsync failedwatch $ do
- void (addWatch i watchevents (toInternalFilePath dir) handler)
+ void (addWatch i watchevents (fromOsPath dir) handler)
`catchIO` failedaddwatch
withLock lock $
- mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$>
+ mapM_ scan =<< filter (`notElem` dirCruft) <$>
getDirectoryContents dir
where
recurse d = watchDir i d ignored scanevents hooks
runhook addHook f ms
_ -> noop
where
- f = fromInternalFilePath fi
+ f = toOsPath fi
-- Closing a file is assumed to mean it's done being written,
-- so a new add event is sent.
go (Closed { isDirectory = False, maybeFilePath = Just fi }) =
- checkfiletype Files.isRegularFile addHook $
- fromInternalFilePath fi
+ checkfiletype Files.isRegularFile addHook (toOsPath fi)
-- When a file or directory is moved in, scan it to add new
-- stuff.
- go (MovedIn { filePath = fi }) = scan $ fromInternalFilePath fi
+ go (MovedIn { filePath = fi }) = scan (toOsPath fi)
go (MovedOut { isDirectory = isd, filePath = fi })
| isd = runhook delDirHook f Nothing
| otherwise = runhook delHook f Nothing
where
- f = fromInternalFilePath fi
+ f = toOsPath fi
-- Verify that the deleted item really doesn't exist,
-- since there can be spurious deletion events for items
| otherwise = guarded $ runhook delHook f Nothing
where
guarded = unlessM (filetype (const True) f)
- f = fromInternalFilePath fi
+ f = toOsPath fi
go (Modified { isDirectory = isd, maybeFilePath = Just fi })
| isd = noop
- | otherwise = runhook modifyHook (fromInternalFilePath fi) Nothing
+ | otherwise = runhook modifyHook (toOsPath fi) Nothing
go _ = noop
indir f = dir </> f
- getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ toRawFilePath $ indir f
+ getstatus f = catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath $ indir f
+
checkfiletype check h f = do
ms <- getstatus f
case ms of
Just s
| check s -> runhook h f ms
_ -> noop
- filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (toRawFilePath (indir f))
+ filetype t f = catchBoolIO $ t <$> R.getSymbolicLinkStatus (fromOsPath (indir f))
failedaddwatch e
-- Inotify fails when there are too many watches with a
-- disk full error.
| isFullError e =
case errHook hooks of
- Nothing -> giveup $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+ Nothing -> giveup $ "failed to add inotify watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")"
Just hook -> tooManyWatches hook dir
-- The directory could have been deleted.
| isDoesNotExistError e = return ()
| otherwise = throw e
- failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+ failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ fromOsPath dir ++ " (" ++ show e ++ ")"
-tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
+tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> OsPath -> IO ()
tooManyWatches hook dir = do
sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing
where
maxwatches = "fs.inotify.max_user_watches"
- basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
+ basewarning = "Too many directories to watch! (Not watching " ++ fromOsPath dir ++")"
withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
withsysctl n = let new = n * 10 in
[ "Increase the limit permanently by running:"
Nothing -> return Nothing
Just s -> return $ parsesysctl s
parsesysctl s = readish =<< lastMaybe (words s)
-
-toInternalFilePath :: FilePath -> RawFilePath
-toInternalFilePath = toRawFilePath
-
-fromInternalFilePath :: RawFilePath -> FilePath
-fromInternalFilePath = fromRawFilePath
type Hook a = Maybe (a -> Maybe FileStatus -> IO ())
data WatchHooks = WatchHooks
- { addHook :: Hook FilePath
- , addSymlinkHook :: Hook FilePath
- , delHook :: Hook FilePath
- , delDirHook :: Hook FilePath
+ { addHook :: Hook OsPath
+ , addSymlinkHook :: Hook OsPath
+ , delHook :: Hook OsPath
+ , delDirHook :: Hook OsPath
, errHook :: Hook String -- error message
- , modifyHook :: Hook FilePath
+ , modifyHook :: Hook OsPath
}
mkWatchHooks :: WatchHooks
import Utility.SystemDirectory
import Utility.Path.AbsRel
import Utility.Exception
-import Utility.FileSystemEncoding
import Utility.OsPath
-import qualified Utility.RawFilePath as R
import Utility.PartialPrelude
{- Like createDirectoryIfMissing True, but it will only create
-- it's not. And on Windows, if they are on different drives,
-- the path will not be relative.
let notbeneath = \(_topdir, (relp, dirs)) ->
- headMaybe dirs /= Just ".." && not (isAbsolute relp)
+ headMaybe dirs /= Just (literalOsPath "..") && not (isAbsolute relp)
case filter notbeneath $ zip topdirs (zip relps relparts) of
((topdir, (_relp, dirs)):_)
-- If dir0 is the same as the topdir, don't try to
setup = do
subdir <- makenewdir (1 :: Integer)
origenviron <- getEnvironment
- let environ = addEntry var subdir origenviron
+ let environ = addEntry var (fromOsPath subdir) origenviron
-- gpg is picky about permissions on its home dir
- liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $
+ liftIO $ void $ tryIO $ modifyFileMode (fromOsPath subdir) $
removeModes $ otherGroupModes
-- For some reason, recent gpg needs a trustdb to be set up.
_ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty
( do
installfile top lib
checksymlink lib
- return $ Just $ fromRawFilePath $ parentDir $ toRawFilePath lib
+ return $ Just $ fromOsPath $ parentDir $ toOsPath lib
, return Nothing
)
where
import System.Posix.Process
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
-import qualified System.FilePath.ByteString as P
import Data.Maybe
import Data.List
import Network.BSD
where
go abslockfile sidelock = do
(tmp, h) <- openTmpFileIn
- (toOsPath (P.takeDirectory abslockfile))
+ (takeDirectory abslockfile)
(literalOsPath "locktmp")
let tmp' = fromOsPath tmp
setFileMode tmp' (combineModes readModes)
removeWhenExistsWith removeLink tmp'
return Nothing
let tooklock st = return $ Just $ LockHandle abslockfile st sidelock
- linkToLock sidelock tmp' abslockfile >>= \case
+ linkToLock sidelock tmp' (fromOsPath abslockfile) >>= \case
Just lckst -> do
removeWhenExistsWith removeLink tmp'
tooklock lckst
-- the pidlock was taken on,
-- we know that the pidlock is
-- stale, and can take it over.
- rename tmp' abslockfile
+ rename tmp' (fromOsPath abslockfile)
tooklock tmpst
_ -> failedlock
Right _ -> do
_ <- tryIO $ createLink src dest
ifM (catchBoolIO checklinked)
- ( ifM (catchBoolIO $ not <$> checkInsaneLustre dest)
+ ( ifM (catchBoolIO $ not <$> checkInsaneLustre (toOsPath dest))
( catchMaybeIO $ getFileStatus dest
, return Nothing
)
-- We can detect this insanity by getting the directory contents after
-- making the link, and checking to see if 2 copies of the dest file,
-- with the SAME FILENAME exist.
-checkInsaneLustre :: RawFilePath -> IO Bool
+checkInsaneLustre :: OsPath -> IO Bool
checkInsaneLustre dest = do
- fs <- dirContents (P.takeDirectory dest)
+ fs <- dirContents (takeDirectory dest)
case length (filter (== dest) fs) of
1 -> return False -- whew!
0 -> return True -- wtf?
_ -> do
-- Try to clean up the extra copy we made
-- that has the same name. Egads.
- _ <- tryIO $ removeLink dest
+ _ <- tryIO $ removeLink $ fromOsPath dest
return True
-- | Waits as necessary to take a lock.
| n > 0 = liftIO (tryLock lockfile) >>= \case
Nothing -> do
when (n == pred timeout) $
- displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)"
+ displaymessage $ "waiting for pid lock file " ++ fromOsPath lockfile ++ " which is held by another process (or may be stale)"
liftIO $ threadDelaySeconds (Seconds 1)
go (pred n)
Just lckh -> do
waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m a
waitedLock (Seconds timeout) lockfile displaymessage = do
- displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile
- giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile
+ displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromOsPath lockfile
+ giveup $ "Gave up waiting for pid lock file " ++ fromOsPath lockfile
-- | Use when the pid lock has already been taken by another thread of the
-- same process.
alreadyLocked :: MonadIO m => PidLockFile -> m LockHandle
alreadyLocked lockfile = liftIO $ do
abslockfile <- absPath lockfile
- st <- getFileStatus abslockfile
+ st <- getFileStatus (fromOsPath abslockfile)
return $ LockHandle abslockfile st Nothing
dropLock :: LockHandle -> IO ()
-- Drop side lock first, at which point the pid lock will be
-- considered stale.
dropSideLock sidelock
- removeWhenExistsWith removeLink lockfile
+ removeWhenExistsWith removeLink (fromOsPath lockfile)
dropLock ParentLocked = return ()
getLockStatus :: PidLockFile -> IO LockStatus
-- locked to get the LockHandle.
checkSaneLock :: PidLockFile -> LockHandle -> IO Bool
checkSaneLock lockfile (LockHandle _ st _) =
- go =<< catchMaybeIO (getFileStatus lockfile)
+ go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile))
where
go Nothing = return False
go (Just st') = return $
-- The parent process should keep running as long as the child
-- process is running, since the child inherits the environment and will
-- not see unsetLockEnv.
-pidLockEnv :: RawFilePath -> IO String
+pidLockEnv :: OsPath -> IO String
pidLockEnv lockfile = do
- abslockfile <- fromRawFilePath <$> absPath lockfile
+ abslockfile <- fromOsPath <$> absPath lockfile
return $ "PIDLOCK_" ++ filter legalInEnvVar abslockfile
pidLockEnvValue :: String
import Utility.FileMode
import Utility.LockFile.LockStatus
import Utility.OpenFd
+import Utility.OsPath
import System.IO
import System.Posix.Types
import System.FilePath.ByteString (RawFilePath)
import Data.Maybe
-type LockFile = RawFilePath
+type LockFile = OsPath
newtype LockHandle = LockHandle Fd
-- Close on exec flag is set so child processes do not inherit the lock.
openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd
openLockFile lockreq filemode lockfile = do
- l <- applyModeSetter filemode lockfile $ \filemode' ->
- openFdWithMode lockfile openfor filemode' defaultFileFlags
+ l <- applyModeSetter filemode lockfile' $ \filemode' ->
+ openFdWithMode lockfile' openfor filemode' defaultFileFlags
setFdOption l CloseOnExec True
return l
where
+ lockfile' = fromOsPath lockfile
openfor = case lockreq of
ReadLock -> ReadOnly
_ -> ReadWrite
-- else.
checkSaneLock :: LockFile -> LockHandle -> IO Bool
checkSaneLock lockfile (LockHandle fd) =
- go =<< catchMaybeIO (getFileStatus lockfile)
+ go =<< catchMaybeIO (getFileStatus (fromOsPath lockfile))
where
go Nothing = return False
go (Just st) = do
) where
import Utility.Monad
+import Utility.OsPath
import System.IO.Unsafe (unsafePerformIO)
-import System.FilePath.ByteString (RawFilePath)
import qualified Data.Map.Strict as M
import Control.Concurrent.STM
import Control.Exception
-type LockFile = RawFilePath
+type LockFile = OsPath
data LockMode = LockExclusive | LockShared
deriving (Eq)
prop_dirContains_regressionTest,
) where
-import qualified Data.ByteString as B
import Data.List
import Data.Maybe
-import Data.Char
import Control.Applicative
import Prelude
import Common
-import Utility.Path
import Utility.QuickCheck
+import qualified Utility.OsString as OS
prop_upFrom_basics :: TestableFilePath -> Bool
prop_upFrom_basics tdir
| dir == "/" = p == Nothing
| otherwise = p /= Just dir
where
- p = fromRawFilePath <$> upFrom (toRawFilePath dir)
+ p = fromOsPath <$> upFrom (toOsPath dir)
dir = fromTestableFilePath tdir
prop_relPathDirToFileAbs_basics :: TestableFilePath -> Bool
prop_relPathDirToFileAbs_basics pt = and
- [ relPathDirToFileAbs p (p </> "bar") == "bar"
- , relPathDirToFileAbs (p </> "bar") p == ".."
- , relPathDirToFileAbs p p == ""
+ [ relPathDirToFileAbs p (p </> literalOsPath "bar") == literalOsPath "bar"
+ , relPathDirToFileAbs (p </> literalOsPath "bar") p == literalOsPath ".."
+ , relPathDirToFileAbs p p == literalOsPath ""
]
where
-- relPathDirToFileAbs needs absolute paths, so make the path
-- absolute by adding a path separator to the front.
- p = pathSeparator `B.cons` relf
+ p = pathSeparator `OS.cons` relf
-- Make the input a relative path. On windows, make sure it does
-- not contain anything that looks like a drive letter.
- relf = B.dropWhile isPathSeparator $
- B.filter (not . skipchar) $
- toRawFilePath (fromTestableFilePath pt)
- skipchar b = b == (fromIntegral (ord ':'))
+ relf = OS.dropWhile isPathSeparator $
+ OS.filter (not . skipchar) $
+ toOsPath (fromTestableFilePath pt)
+ skipchar b = b == unsafeFromChar ':'
prop_relPathDirToFileAbs_regressionTest :: Bool
prop_relPathDirToFileAbs_regressionTest = same_dir_shortcurcuits_at_difference
- location, but it's not really the same directory.
- Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference =
- relPathDirToFileAbs (joinPath [pathSeparator `B.cons` "tmp", "r", "lll", "xxx", "yyy", "18"])
- (joinPath [pathSeparator `B.cons` "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
- == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+ relPathDirToFileAbs (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", "lll", "xxx", "yyy", "18"])
+ (mkp [fromOsPath (pathSeparator `OS.cons` literalOsPath "tmp"), "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
+ == mkp ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
+ where
+ mkp = joinPath . map literalOsPath
prop_dirContains_regressionTest :: Bool
prop_dirContains_regressionTest = and
- [ not $ dirContains "." ".."
- , not $ dirContains ".." "../.."
- , dirContains "." "foo"
- , dirContains "." "."
- , dirContains ".." ".."
- , dirContains "../.." "../.."
- , dirContains "." "./foo"
- , dirContains ".." "../foo"
- , dirContains "../.." "../foo"
- , dirContains "../.." "../../foo"
- , not $ dirContains "../.." "../../.."
+ [ not $ dc "." ".."
+ , not $ dc ".." "../.."
+ , dc "." "foo"
+ , dc "." "."
+ , dc ".." ".."
+ , dc "../.." "../.."
+ , dc "." "./foo"
+ , dc ".." "../foo"
+ , dc "../.." "../foo"
+ , dc "../.." "../../foo"
+ , not $ dc "../.." "../../.."
]
+ where
+ dc x y = dirContains (literalOsPath x) (literalOsPath y)
import Utility.Path
import Utility.OsPath
-import Utility.FileSystemEncoding
+import Utility.SystemDirectory
import qualified Data.ByteString as B
import qualified System.FilePath.Windows.ByteString as P
-import System.Directory (getCurrentDirectory)
{- Convert a filepath to use Windows's native namespace.
- This avoids filesystem length limits.
| otherwise = do
-- Make absolute because any '.' and '..' in the path
-- will not be resolved once it's converted.
- cwd <- toRawFilePath <$> getCurrentDirectory
- let p = fromOsPath (simplifyPath (toOsPath (combine cwd f)))
+ cwd <- getCurrentDirectory
+ let p = fromOsPath (simplifyPath (combine cwd (toOsPath f)))
-- Normalize slashes.
let p' = P.normalise p
return (win32_file_namespace <> p')
changeUserSshConfig :: (String -> String) -> IO ()
changeUserSshConfig modifier = do
sshdir <- sshDir
- let configfile = sshdir </> "config"
+ let configfile = sshdir </> literalOsPath "config"
whenM (doesFileExist configfile) $ do
c <- decodeBS . S8.unlines . fileLines'
- <$> F.readFile' (toOsPath (toRawFilePath configfile))
+ <$> F.readFile' configfile
let c' = modifier c
when (c /= c') $ do
-- If it's a symlink, replace the file it
-- points to.
f <- catchDefaultIO configfile (canonicalizePath configfile)
- viaTmp writeSshConfig (toOsPath (toRawFilePath f)) c'
+ viaTmp writeSshConfig f c'
writeSshConfig :: OsPath -> String -> IO ()
writeSshConfig f s = do
setSshConfigMode f = void $ tryIO $ modifyFileMode f $
removeModes [groupWriteMode, otherWriteMode]
-sshDir :: IO FilePath
+sshDir :: IO OsPath
sshDir = do
home <- myHomeDir
- return $ home </> ".ssh"
+ return $ toOsPath home </> literalOsPath ".ssh"
- The directory does not really have to be empty, it just needs to be one
- that should not contain any files with names starting with "@".
-}
-newtype EmptyDirectory = EmptyDirectory FilePath
+newtype EmptyDirectory = EmptyDirectory OsPath
{- Encrypt using symmetric encryption with the specified password. -}
encryptSymmetric
{- Test a value round-trips through symmetric encryption and decryption. -}
test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool
test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $
- withTmpDir (toOsPath "test") $ \d -> do
+ withTmpDir (literalOsPath "test") $ \d -> do
let ed = EmptyDirectory d
enc <- encryptSymmetric a password ed Nothing armoring
(`B.hPutStr` v) B.hGetContents
, std_out = CreatePipe
, std_err = Inherit
, cwd = case med of
- Just (EmptyDirectory d) -> Just d
+ Just (EmptyDirectory d) -> Just (fromOsPath d)
Nothing -> Nothing
}
copyright =<< bracket (setup p) cleanup (go p)
mkSuCommand :: String -> [CommandParam] -> IO (Maybe SuCommand)
#ifndef mingw32_HOST_OS
mkSuCommand cmd ps = do
- pwd <- getCurrentDirectory
+ pwd <- fromOsPath <$> getCurrentDirectory
firstM (\(SuCommand _ p _) -> inSearchPath p) =<< selectcmds pwd
where
selectcmds pwd = ifM (inx <||> (not <$> atconsole))
import Utility.ThreadScheduler
import Utility.FileMode
import Utility.RawFilePath (setOwnerAndGroup)
+import qualified Utility.OsString as OS
import System.PosixCompat.Types
import System.PosixCompat.Files (ownerReadMode, ownerWriteMode, ownerExecuteMode)
newtype OnionAddress = OnionAddress String
deriving (Show, Eq)
-type OnionSocket = FilePath
+type OnionSocket = OsPath
-- | A unique identifier for a hidden service.
type UniqueIdent = String
addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort)
addHiddenService appname uid ident = do
prepHiddenServiceSocketDir appname uid ident
- ls <- lines <$> (readFile =<< findTorrc)
+ ls <- lines <$> (readFile . fromOsPath =<< findTorrc)
let portssocks = mapMaybe (parseportsock . separate isSpace) ls
- case filter (\(_, s) -> s == sockfile) portssocks of
+ case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of
((p, _s):_) -> waithiddenservice 1 p
_ -> do
highports <- R.getStdRandom mkhighports
let newport = fromMaybe (error "internal") $ headMaybe $
filter (`notElem` map fst portssocks) highports
torrc <- findTorrc
- writeFile torrc $ unlines $
+ writeFile (fromOsPath torrc) $ unlines $
ls ++
[ ""
- , "HiddenServiceDir " ++ hiddenServiceDir appname uid ident
+ , "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident)
, "HiddenServicePort " ++ show newport ++
- " unix:" ++ sockfile
+ " unix:" ++ fromOsPath sockfile
]
-- Reload tor, so it will see the new hidden
-- service and generate the hostname file for it.
waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort)
waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running"
waithiddenservice n p = do
- v <- tryIO $ readFile $ hiddenServiceHostnameFile appname uid ident
+ v <- tryIO $ readFile $ fromOsPath $
+ hiddenServiceHostnameFile appname uid ident
case v of
Right s | ".onion\n" `isSuffixOf` s ->
return (OnionAddress (takeWhile (/= '\n') s), p)
-- Has to be inside the torLibDir so tor can create it.
--
-- Has to end with "uid_ident" so getHiddenServiceSocketFile can find it.
-hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> FilePath
-hiddenServiceDir appname uid ident = torLibDir </> appname ++ "_" ++ show uid ++ "_" ++ ident
+hiddenServiceDir :: AppName -> UserID -> UniqueIdent -> OsPath
+hiddenServiceDir appname uid ident =
+ torLibDir </> toOsPath (appname ++ "_" ++ show uid ++ "_" ++ ident)
-hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> FilePath
-hiddenServiceHostnameFile appname uid ident = hiddenServiceDir appname uid ident </> "hostname"
+hiddenServiceHostnameFile :: AppName -> UserID -> UniqueIdent -> OsPath
+hiddenServiceHostnameFile appname uid ident =
+ hiddenServiceDir appname uid ident </> literalOsPath "hostname"
-- | Location of the socket for a hidden service.
--
-- Note that some unix systems limit socket paths to 92 bytes long.
-- That should not be a problem if the UniqueIdent is around the length of
-- a UUID, and the AppName is short.
-hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> FilePath
-hiddenServiceSocketFile appname uid ident = varLibDir </> appname </> show uid ++ "_" ++ ident </> "s"
+hiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> OsPath
+hiddenServiceSocketFile appname uid ident =
+ varLibDir </> toOsPath appname
+ </> toOsPath (show uid ++ "_" ++ ident) </> toOsPath "s"
-- | Parse torrc, to get the socket file used for a hidden service with
-- the specified UniqueIdent.
-getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe FilePath)
+getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath)
getHiddenServiceSocketFile _appname uid ident =
- parse . map words . lines <$> catchDefaultIO "" (readFile =<< findTorrc)
+ parse . map words . lines <$> catchDefaultIO ""
+ (readFile . fromOsPath =<< findTorrc)
where
parse [] = Nothing
parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest)
- | "unix:" `isPrefixOf` hsaddr && hasident hsdir =
- Just (drop (length "unix:") hsaddr)
+ | "unix:" `isPrefixOf` hsaddr && hasident (toOsPath hsdir) =
+ Just $ toOsPath $ drop (length "unix:") hsaddr
| otherwise = parse rest
parse (_:rest) = parse rest
-- Don't look for AppName in the hsdir, because it didn't used to
-- be included.
- hasident hsdir = (show uid ++ "_" ++ ident) `isSuffixOf` takeFileName hsdir
+ hasident hsdir = toOsPath (show uid ++ "_" ++ ident) `OS.isSuffixOf` takeFileName hsdir
-- | Sets up the directory for the socketFile, with appropriate
-- permissions. Must run as root.
prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO ()
prepHiddenServiceSocketDir appname uid ident = do
createDirectoryIfMissing True d
- setOwnerAndGroup (toRawFilePath d) uid (-1)
- modifyFileMode (toRawFilePath d) $
+ setOwnerAndGroup (fromOsPath d) uid (-1)
+ modifyFileMode (fromOsPath d) $
addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode]
where
d = takeDirectory $ hiddenServiceSocketFile appname uid ident
-- | Finds the system's torrc file, in any of the typical locations of it.
-- Returns the first found. If there is no system torrc file, defaults to
-- /etc/tor/torrc.
-findTorrc :: IO FilePath
-findTorrc = fromMaybe "/etc/tor/torrc" <$> firstM doesFileExist
- -- Debian
- [ "/etc/tor/torrc"
+findTorrc :: IO OsPath
+findTorrc = fromMaybe deftorrc <$> firstM doesFileExist
+ [ deftorrc
-- Some systems put it here instead.
- , "/etc/torrc"
+ , literalOsPath "/etc/torrc"
-- Default when installed from source
- , "/usr/local/etc/tor/torrc"
+ , literalOsPath "/usr/local/etc/tor/torrc"
]
+ where
+ -- Debian uses this
+ deftorrc = literalOsPath "/etc/tor/torrc"
-torLibDir :: FilePath
-torLibDir = "/var/lib/tor"
+torLibDir :: OsPath
+torLibDir = literalOsPath "/var/lib/tor"
-varLibDir :: FilePath
-varLibDir = "/var/lib"
+varLibDir :: OsPath
+varLibDir = literalOsPath "/var/lib"
torIsInstalled :: IO Bool
torIsInstalled = inSearchPath "tor"
projects / git-annex.git / commitdiff